home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / back_end / lookup.t < prev    next >
Encoding:
Text File  |  1990-07-12  |  15.7 KB  |  351 lines
  1. (herald (back_end lookkup)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. (define (all-important-refs-are-calls? var)
  5.   (every? (lambda (ref)
  6.         (or (eq? (node-role ref) call-proc)
  7.         (and (eq? (node-role ref) (call-arg 2))
  8.              (let ((call (node-parent ref)))
  9.                (or (primop-ref? (call-proc call) primop/*define)
  10.                (primop-ref? (call-proc call) primop/*lset))))))
  11.       (variable-refs var)))
  12.  
  13. (define (var-is-vcell? var)
  14.   (and (not (all-important-refs-are-calls? var))
  15.        (neq? var *the-environment*)))
  16.  
  17. ;;; ACCESS-VALUE This is the primary routine to get addressability to values.
  18. ;;; Just a giant case statement.
  19.  
  20. (define (access-value node value)
  21.   (cond ((and (variable? value)
  22.           (not (variable-binder value))
  23.           (var-is-vcell? value))
  24.      (let ((acc (lookup node (get-lvalue value) nil)))
  25.        (let ((reg (get-register 'pointer node '*)))
  26.          (generate-move acc reg)
  27.          (set (reg-node reg) -1)
  28.          (reg-offset reg 2))))
  29.     (else
  30.      (really-access-value node value))))
  31.  
  32. (define (really-access-value node value)               
  33.  (let ((value (cond ((and (variable? value) (variable-known value))
  34.                      => lambda-self-var)
  35.                     (else value))))
  36.   (cond ((register-loc value)
  37.          => (lambda (spec)
  38.               (cond ((fixnum? spec))
  39.                     (else
  40.                      (cond ((pair? (car spec))
  41.                             (unlock (caar spec))
  42.                             (cond ((reg-node (caar spec))
  43.                                    => (lambda (var) (maybe-kill-if-dying var node))))
  44.                             (unlock (cdar spec)))
  45.                            (else
  46.                             (unlock (car spec))
  47.                             (cond ((reg-node (car spec))
  48.                                    => (lambda (var) (maybe-kill-if-dying var node))))))
  49.                      (set (register-loc value) nil)))
  50.               spec))
  51.         ((temp-loc value))
  52.         ((variable? value)
  53.          (let ((binder (variable-binder value)))
  54.            (cond ((not binder)
  55.                   (lookup node value nil))
  56.                  ((and (fx= (variable-number value) 0) 
  57.                        (assq binder (closure-env *unit*)))
  58.                   (lookup node binder nil))
  59.                  (else
  60.                   (lookup node value binder)))))
  61.         ((primop? value)
  62.          (if (eq? value primop/undefined)
  63.              (machine-num 0)
  64.              (lookup node value nil)))
  65.         ((eq? value '#T)
  66.          (machine-num header/true))
  67.         ((or (eq? value '#F) (eq? value '()))
  68.           nil-reg)
  69.         ((addressable? value)
  70.          (lit value))
  71.         (else
  72.          (lookup node value nil)))))
  73.  
  74. (define (maybe-kill-if-dying var node)
  75.   (or (any? (lambda (ref)
  76.           (and (reference-node? ref) (eq? (leaf-value ref) var)))
  77.         (call-proc+args node))
  78.       (kill-if-dying var node)))
  79.  
  80. ;;; LOOKUP If the value is a known procedure, if it is in the unit we get it
  81. ;;; from there, otherwise we get the variable which the known procedure is
  82. ;;; bound to.
  83.  
  84. (define (lookup node value lambda-bound?)
  85.   (xselect (lambda-strategy *lambda*)
  86.     ((strategy/stack strategy/ezclose)
  87.      (fetch-from-stack node value lambda-bound?))
  88.     ((strategy/vframe strategy/hack)
  89.      (let ((contour (lambda-self-var *lambda*)))
  90.        (->register 'pointer node contour '*)
  91.        (fetch-from-vframe node contour value lambda-bound?)))
  92.     ((strategy/heap)
  93.      (let ((contour (lambda-self-var *lambda*)))
  94.        (->register 'pointer node contour '*)
  95.        (fetch-from-heap node contour value lambda-bound?)))))
  96.  
  97.  
  98.                                 
  99. ;;; ACCESS-FROM-UNIT Get from unit when there is a closure-internal-template.
  100. ;;; If we have one, just offset from template-pointer. If we are internal to
  101. ;;; a closure which has one, get it first and then offset into unit.
  102.  
  103.  
  104. (define (access-from-unit node contour var)
  105.   (let ((closure (environment-closure (lambda-env (variable-binder contour)))))
  106.     (cond ((closure-cit-offset closure)
  107.            => (lambda (current-offset) 
  108.                 (let ((cl? (or (and (node? var) (lambda-node? var))
  109.                            (closure? var)))
  110.                       (disp (fx- (cdr (assq var (closure-env *unit*))) 
  111.                                  (fx+ current-offset tag/extend))))
  112.                   (cond ((and (eq? (lambda-strategy *lambda*) strategy/heap)
  113.                               (eq? contour (car (closure-members closure))))
  114.                          (if cl?
  115.                              (list (reg-offset TP (fx+ disp tag/extend)))
  116.                              (reg-offset TP disp)))
  117.                         ((register-loc (variable-binder (car (closure-members closure))))
  118.                          => (lambda (reg)
  119.                               (if cl?
  120.                                   (list (reg-offset reg (fx+ disp tag/extend)))
  121.                                   (reg-offset reg disp))))
  122.                         (else
  123.                          (let* ((c-reg (register-loc contour))
  124.                                 (reg (get-register 'pointer node '*)))
  125.                            (generate-move
  126.                               (reg-offset c-reg
  127.                                           (fx- (fx- 0 tag/extend)
  128.                                                (cdr (assq contour
  129.                                                     (closure-env closure)))))
  130.                               reg)                        
  131.                            (mark (variable-binder (car (closure-members closure)))
  132.                                  reg)
  133.                            (if cl?
  134.                                (list (reg-offset reg (fx+ disp tag/extend)))
  135.                                (reg-offset reg disp))))))))
  136.           (else nil))))
  137.  
  138.  
  139. (define (get-env var)
  140.   (lambda-env (variable-binder var)))
  141.                                       
  142.  
  143. ;;; Yukk.  Here we get a variable from a stack frame.  If it is in the frame
  144. ;;; we are OK.  Otherwise we chain down stack frames as long as they are there.
  145. ;;; These frames are all simple offsets from SP.  When we arrive at a pointer
  146. ;;; into the heap, we load that pointer into a register and go to the heap
  147. ;;; code to do the rest.
  148.  
  149. (define (fetch-from-vframe node contour value lambda-bound?)
  150.   (iterate loop ((offset 0) (l (variable-binder contour)))
  151.     (select (lambda-strategy l)
  152.       ((strategy/label strategy/open)
  153.        (loop offset (node-parent (node-parent l))))
  154.       (else
  155.        (cond ((not (lambda-env l))
  156.               (loop offset (node-parent (node-parent l))))
  157.              (else
  158.               (let* ((env (lambda-env l))
  159.                      (closure (environment-closure env)))
  160.                 (cond ((and lambda-bound? (assq value (closure-env closure)))
  161.                        => (lambda (env-pair) 
  162.                             (reg-offset (register-loc contour)
  163.                                         (fx+ (fx- (cdr env-pair) tag/extend)
  164.                                              (fx- offset
  165.                                                   (environment-cic-offset env))))))
  166.                       ((closure-link closure)
  167.                        => (lambda (link)
  168.                        (let ((accessor (reg-offset (register-loc contour)
  169.                                                    (fx- (fx+ offset CELL)
  170.                                                  (fx+ (environment-cic-offset env) tag/extend)))))
  171.                          (into-register 'pointer node link accessor '*)
  172.                          (xselect (lambda-strategy (variable-binder link))
  173.                             ((strategy/heap) 
  174.                              (fetch-from-heap node link value lambda-bound?))
  175.                             ((strategy/vframe strategy/hack) 
  176.                              (fetch-from-vframe node link value lambda-bound?))))))
  177.                       ((labels-master-lambda? l)
  178.                        (let* ((p (node-parent l))
  179.                               (node ((call-arg 1) p)))
  180.                          (cond ((lambda-node? node)
  181.                                 (loop (fx+ (fx- (closure-size closure) 
  182.                                                 (environment-cic-offset env))
  183.                                            (fx+ offset
  184.                                                 (closure-size 
  185.                                                   (environment-closure
  186.                                                     (lambda-env node)))))
  187.                                       (node-parent p)))
  188.                                (else 
  189.                                 (loop (fx+ (fx- (closure-size closure) 
  190.                                                 (environment-cic-offset env))
  191.                                            offset)
  192.                                       (node-parent p))))))
  193.                       (else
  194.                        (loop (fx+ (fx- (closure-size closure) 
  195.                                        (environment-cic-offset env))
  196.                                   offset)
  197.                              (node-parent (node-parent l))))))))))))
  198.  
  199.                                                  
  200. (define (fetch-from-stack node value lambda-bound?)
  201.   (iterate loop ((offset 0) (l *lambda*))
  202.     (select (lambda-strategy l)
  203.       ((strategy/open)
  204.        (loop offset (node-parent (node-parent l))))
  205.       ((strategy/label strategy/heap)
  206.        (let* ((p (node-parent l))
  207.               (node ((call-arg 1) p)))
  208.          (cond ((and (labels-master-lambda? l) (lambda-node? node))
  209.                 (loop (fx+ (closure-size (environment-closure (lambda-env node)))
  210.                            offset)
  211.                       (node-parent p)))
  212.                (else 
  213.                 (loop offset (node-parent p))))))
  214.       (else
  215.        (cond ((not (lambda-env l))
  216.               (loop offset (node-parent (node-parent l))))
  217.              (else
  218.               (let ((closure (environment-closure (lambda-env l))))
  219.                 (cond ((and lambda-bound? (assq value (closure-env closure)))
  220.                        => (lambda (env-pair) 
  221.                             (reg-offset SP (fx+ offset 
  222.                                                 (fx+ *stack-pos* (cdr env-pair))))))
  223.                       ((closure-link closure)
  224.                        => (lambda (link)
  225.                        (let ((accessor (reg-offset SP (fx+ *stack-pos*
  226.                                                             (fx+ offset CELL)))))
  227.                          (into-register 'pointer node link accessor '*)
  228.                          (xselect (lambda-strategy (variable-binder link))
  229.                             ((strategy/heap) 
  230.                              (fetch-from-heap node link value lambda-bound?))
  231.                             ((strategy/vframe strategy/hack) 
  232.                              (fetch-from-vframe node link value lambda-bound?))))))
  233.                       ((labels-master-lambda? l)
  234.                        (let* ((p (node-parent l))
  235.                               (node ((call-arg 1) p)))
  236.                          (cond ((lambda-node? node)
  237.                                 (loop (fx+ (fx+ (closure-size closure)
  238.                                                 (closure-size (environment-closure
  239.                                                                 (lambda-env node))))
  240.                                            offset)
  241.                                       (node-parent p)))
  242.                                (else 
  243.                                 (loop (fx+ (closure-size closure) offset)
  244.                                       (node-parent p))))))
  245.                       (else
  246.                        (loop (fx+ (closure-size closure) offset)
  247.                              (node-parent (node-parent l))))))))))))
  248.                           
  249.  
  250.  
  251. (define (closure-internal-closure? value closure)
  252.   (cond ((neq? closure *unit*)
  253.          (memq? value (closure-members closure)))
  254.         (else
  255.          (or (and (node? value) (lambda-node? value))
  256.              (closure? value)))))
  257.  
  258. (define (fetch-from-heap node contour value lambda-bound?) 
  259.   (iterate loop ((env (get-env contour)) (contour contour)) 
  260.     (let ((a-list (closure-env (environment-closure env)))
  261.           (current-offset (environment-cic-offset env)))
  262.       (cond ((assq value a-list)
  263.              => (lambda (pair)
  264.                   (if (closure-internal-closure? value
  265.                                                  (environment-closure env))
  266.                       (list (reg-offset (register-loc contour)  ; *** hack
  267.                                         (fx- (cdr pair) current-offset)))
  268.                       (reg-offset (register-loc contour)
  269.                                   (fx- (cdr pair)
  270.                                        (fx+ current-offset tag/extend))))))
  271.             ((and (not lambda-bound?) (access-from-unit node contour value)))
  272.             ((neq? (environment-closure env) *unit*)
  273.              (into-register 'pointer node (caadr a-list)
  274.                 (reg-offset  (register-loc contour)
  275.                              (fx+ (fx- 0 current-offset) tag/extend))
  276.                 '*)
  277.              (loop (get-env (caadr a-list)) (caadr a-list)))
  278.             (else
  279.              (bug "Couldn't find ~s~% in call ~s"
  280.                   value
  281.                   (pp-cps node)))))))
  282.  
  283. ;;; Code to get a continuation off the stack.
  284. ;;; Search up the tree until we find it.
  285. ;;; This relies on generating code for the body of a labels FIRST.
  286.  
  287.  
  288. (define (fetch-continuation-from-stack node var)
  289.   (iterate loop ((offset 0) (l (node-parent node)))
  290.     (cond ((eq? (variable-binder var) l)
  291.            offset)
  292.           (else
  293.            (select (lambda-strategy l)
  294.              ((strategy/stack)
  295.               (loop (fx+ (closure-size (environment-closure (lambda-env l)))
  296.                          offset)
  297.                    (node-parent (node-parent l))))
  298.              (else
  299.               (loop offset (node-parent (node-parent l)))))))))
  300.  
  301. (define (restore-continuation node leaf)
  302.   (let ((proc (call-proc node)))
  303.     (let ((stop (cond ((primop-node? proc) nil)
  304.                       ((variable-known (reference-variable proc))
  305.                        => (lambda (l)
  306.                             (let ((p (node-parent (node-parent l))))
  307.                               (if (labels-master-lambda? p) p nil))))
  308.                       (else nil))))
  309.       (really-restore-continuation node (leaf-value leaf) stop))))
  310.  
  311. (define (restore-ezclose-continuation node proc)
  312.   (really-restore-continuation node (leaf-value ((call-arg 1) node))
  313.                                     (node-parent (node-parent proc))))
  314.  
  315. (define (restore-vframe-continuation node proc)
  316.   (really-restore-continuation node (leaf-value ((call-arg 1) node))
  317.                                     (node-parent (node-parent proc))))
  318.  
  319.  
  320. (define (really-restore-continuation node var stop)
  321.   (let* ((binder (variable-binder var))
  322.          (y-lambda (node-parent (node-parent binder)))
  323.          (n (fetch-continuation-from-stack node var)))
  324.     (if (not (labels-master-lambda? y-lambda))
  325.         (adjust-stack-pointer n)
  326.         (select (lambda-strategy y-lambda)
  327.           ((strategy/heap)           
  328.            (if (eq? (node-role binder) (call-arg 1))
  329.                (let ((pair (lambda-live y-lambda)))
  330.                  (remove-stack (cdr pair) (fx+ n (car pair)) nil))
  331.                (adjust-stack-pointer n)))
  332.           (else                       
  333.            (remove-stack y-lambda n stop))))))
  334.  
  335. (define (remove-stack y-lambda n stop)
  336.   (iterate loop ((y-lambda y-lambda)
  337.                  (n n))
  338.     (if (or (null? y-lambda) (eq? y-lambda stop))
  339.         (adjust-stack-pointer n)
  340.         (select (lambda-strategy y-lambda)
  341.           ((strategy/ezclose strategy/label)
  342.            (let ((pair (lambda-live y-lambda)))
  343.              (loop (cdr pair) (fx+ (car pair) n))))
  344.           ((strategy/vframe)
  345.            (adjust-stack-pointer n)
  346.            (let ((pair (lambda-live y-lambda)))                   
  347.              (generate-vframe-test (car pair))
  348.              (loop (cdr pair) 0)))
  349.           (else 
  350.            (adjust-stack-pointer n))))))
  351.